home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Moscow ML 1.42 / src / mosmllib / Location.sml < prev    next >
Encoding:
Text File  |  1997-08-18  |  4.9 KB  |  171 lines  |  [TEXT/R*ch]
  1. (* Printing a location in the source program.
  2.  * For use with mosmllex and mosmlyac.  
  3.  * Based on src/compiler/location from the Caml Light 0.6 distribution.
  4.  *)
  5.  
  6. open BasicIO Nonstdio Lexing Parsing;
  7.  
  8. datatype Location =
  9.     Loc of int     (* Position of the first character                  *)
  10.          * int     (* Position of the character following the last one *)
  11.  
  12. val nilLocation = Loc(0,0);
  13.  
  14. fun getCurrentLocation () =
  15.   Loc(Parsing.symbolStart(), Parsing.symbolEnd())
  16.  
  17. fun mkLoc x = (getCurrentLocation(), x);
  18.  
  19. fun xLR (loc, _) = loc
  20. and xL (Loc(l,r), _) = l
  21. and xR (Loc(l,r), _) = r
  22.  
  23. fun xxLR (Loc(l,_), _) (Loc(_,r),_) = Loc(l,r);
  24. fun xxRL (Loc(_,r), _) (Loc(l,_),_) = Loc(r,l);
  25.  
  26. val msgString = outputc std_out;
  27. val msgChar   = output_char std_out;
  28. fun msgInt (i : int) = outputc std_out (makestring i)
  29. fun msgChars n c =
  30.   if n > 0 then (msgChar c; msgChars (n-1) c) else ();
  31. fun msgEOL () = (output_char std_out #"\n"; flush_out std_out);
  32.  
  33. fun incr (r as ref v) = r := v+1;
  34. fun decr (r as ref v) = r := v-1;
  35.  
  36. fun errLines char1 char2 charline1 line1 line2 =
  37. (
  38.   msgString ", line "; msgInt line1;
  39.   if line2 <> line1 then ( msgString "-"; msgInt line2 ) else ();
  40.   msgString ", characters ";
  41.   msgInt (char1-charline1); msgString "-"; msgInt (char2-charline1);
  42.   msgString ":"
  43. );
  44.  
  45. fun errPrompt s = (msgString "! "; msgString s);
  46.  
  47. fun for f i j = if i > j then () else (f i : unit; for f (i+1) j);                                    
  48.  
  49. fun errLoc input seek line_flag (Loc(pos1, pos2)) =
  50.   let
  51.     fun skipLine () =
  52.       (case input() of #"\^Z" => () | #"\n" => () | _ => skipLine())
  53.       handle Size => ()
  54.     and copyLine () =
  55.       (case input() of
  56.            #"\^Z" => raise Size
  57.          | #"\n" => msgEOL()
  58.          | c => (msgChar c; copyLine()))
  59.       handle Size => (msgString "<EOF>"; msgEOL())
  60.     and tr_line first len ch =
  61.       let
  62.         val c = ref #" "
  63.         val f = ref first
  64.         val l = ref len
  65.         fun loop f l =
  66.           (case input() of
  67.                 #"\^Z" => raise Size
  68.               | #"\n" => ()
  69.               | c =>
  70.                   if f > 0 then
  71.                     (msgChar(if c = #"\t" then c else #" "); loop (f-1) l)
  72.                   else if l > 0 then
  73.                     (msgChar(if c = #"\t" then c else ch); loop f (l-1))
  74.                   else loop f l)
  75.           handle Size => msgChars 5 ch
  76.       in loop first len end
  77.     val pos = ref 0
  78.     val line1 = ref 1
  79.     val line1_pos = ref 0
  80.     val line2 = ref 1
  81.     val line2_pos = ref 0
  82.   in
  83.     seek 0;
  84.     (while !pos < pos1 do
  85.        (incr pos;
  86.         case input() of
  87.             #"\^Z" => raise Size
  88.           | #"\n" => (incr line1; line1_pos := !pos)
  89.           | _ => ()))
  90.     handle Size => ();
  91.     line2 := !line1;
  92.     line2_pos := !line1_pos;
  93.     (while !pos < pos2 do
  94.        (incr pos;
  95.         case input() of
  96.             #"\^Z" => raise Size
  97.           | #"\n" => (incr line2; line2_pos := !pos)
  98.           | _ => ()))
  99.     handle Size => ();
  100.     if line_flag then
  101.       errLines pos1 pos2 (!line1_pos) (!line1) (!line2)
  102.     else ();
  103.     msgEOL();
  104.     if !line1 = !line2 then
  105.       (seek (!line1_pos);
  106.        errPrompt ""; copyLine ();
  107.        seek (!line1_pos);
  108.        errPrompt ""; tr_line (pos1 - !line1_pos) (pos2 - pos1) #"^";
  109.        msgEOL())
  110.     else
  111.       (
  112.       seek (!line1_pos);
  113.       errPrompt ""; tr_line 0 (pos1 - !line1_pos) #".";
  114.       seek pos1;
  115.       copyLine();
  116.       if !line2 - !line1 <= 8 then
  117.         (for (fn i => (errPrompt ""; copyLine()))
  118.              (!line1 + 1) (!line2 - 1))
  119.       else
  120.         (for (fn i => (errPrompt ""; copyLine()))
  121.              (!line1 + 1) (!line1 + 3);
  122.          errPrompt ".........."; msgEOL();
  123.          for (fn i => skipLine())
  124.              (!line1 + 4) (!line2 - 4);
  125.          for (fn i => (errPrompt ""; copyLine()))
  126.              (!line2 - 3) (!line2 - 1));
  127.       errPrompt "";
  128.       (for (fn i => msgChar(input()))
  129.            (!line2_pos) (pos2 - 1);
  130.        tr_line 0 100 #".")
  131.       handle Size => msgString "<EOF>";
  132.       msgEOL()
  133.       )
  134.   end;
  135.  
  136. fun errLocation (input_name, input_stream, input_lexbuf) loc =
  137.   if size input_name > 0 then
  138.     let val p = pos_in input_stream in
  139.       msgString "File \""; msgString input_name; msgString "\"";
  140.       errLoc (fn () => input_char input_stream) (seek_in input_stream)
  141.              true loc;
  142.       seek_in input_stream p
  143.     end
  144.   else
  145.     let
  146.       val curr_pos = ref 0
  147.       fun input () =
  148.         let val c =
  149.           if !curr_pos >= 2048 then
  150.             raise Size
  151.           else if !curr_pos >= 0 then
  152.             (CharVector.sub(getLexBuffer input_lexbuf, !curr_pos)
  153.              handle Subscript => #"\n")
  154.           else
  155.             #"."
  156.         in incr curr_pos; c end
  157.       and seek pos =
  158.         curr_pos := pos - getLexAbsPos input_lexbuf
  159.     in
  160.       errPrompt "Toplevel input:";
  161.       errLoc input seek false loc
  162.     end
  163. ;
  164.  
  165. fun errMsg file_stream_lexbuf loc msg =
  166. (
  167.   errLocation file_stream_lexbuf loc;
  168.   errPrompt msg; msgEOL(); msgEOL();
  169.   raise Fail "Error encountered"
  170. );
  171.